home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 January / PC Plus Super CD No55a (PCP-147A-1-99) (Disc 1) (1998).iso / linux / developers / visualtcl / windows / vtcl / lib / tclet.tcl < prev    next >
Encoding:
Text File  |  1997-04-09  |  4.9 KB  |  133 lines
  1. ##############################################################################
  2. # $Id: tclet.tcl,v 1.3 1997/04/10 04:28:45 stewart Exp $
  3. #
  4. # tclet.tcl - procedures for creating tclets from compounds
  5. #
  6. # Copyright (C) 1996-1997 Stewart Allen
  7. #
  8. # This program is free software; you can redistribute it and/or
  9. # modify it under the terms of the GNU General Public License
  10. # as published by the Free Software Foundation; either version 2
  11. # of the License, or (at your option) any later version.
  12. #
  13. # This program is distributed in the hope that it will be useful,
  14. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. # GNU General Public License for more details.
  17. #
  18. # You should have received a copy of the GNU General Public License
  19. # along with this program; if not, write to the Free Software
  20. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ##############################################################################
  23. #
  24.  
  25. proc vTcl:create_tclet {target} {
  26.     global vTcl
  27.     if {[vTcl:get_class $target] != "Toplevel"} {
  28.         vTcl:error "You must select a Toplevel\nWindow as the Tclet base"
  29.         return
  30.     }
  31.     set vTcl(cmp,alias) ""
  32.     set vTcl(cmp,index) 0
  33.     set cmpd [vTcl:gen_compound $target]
  34.     set cmd [vTcl:tclet_from_cmpd "" "" $cmpd]
  35.     set file [vTcl:get_file save "Export Tclet"]
  36.     if {$file != ""} {
  37.         if [catch {set out [open $file w]}] {
  38.             vTcl:error "Error saving to file: $error"
  39.             return
  40.         }
  41.         puts $out $vTcl(head,vars)                           ;vTcl:statbar 5
  42.         puts $out [vTcl:save_vars]                           ;vTcl:statbar 15
  43.         set body [string trim [info body init]]              ;vTcl:statbar 20
  44.         puts $out $vTcl(head,procs)                          ;vTcl:statbar 25
  45.         puts $out "proc init \{argc argv\} \{\n$body\n\}\n"  ;vTcl:statbar 30
  46.         puts $out "init \$argc \$argv\n"                     ;vTcl:statbar 35
  47.         puts $out [vTcl:save_procs]                          ;vTcl:statbar 55
  48.         puts $out $vTcl(head,gui)                            ;vTcl:statbar 65
  49.         puts $out $cmd                                       ;vTcl:statbar 75
  50.         puts $out "main \$argc \$argv"                       ;vTcl:statbar 95
  51.         close $out                                           ;vTcl:statbar 0
  52.     }
  53. }
  54.  
  55. proc vTcl:tclet_from_cmpd {base name compound {level 0}} {
  56.     global vTcl widget
  57.     set todo ""
  58.     foreach i $compound {
  59.         set type [string trim [lindex $i 0]]
  60.         set opts [string trim [lindex $i 1]]
  61.         set mgr  [string trim [lindex $i 2]]
  62.         set mgrt [string trim [lindex $mgr 0]]
  63.         set mgri [string trim [lindex $mgr 1]]
  64.         set bind [string trim [lindex $i 3]]
  65.         set menu [string trim [lindex $i 4]]
  66.         set chld [string trim [lindex $i 5]]
  67.         set wdgt [string trim [lindex $i 6]]
  68.         set alis [string trim [lindex $i 7]]
  69.         set grid [string trim [lindex $i 8]]
  70.         set proc [string trim [lindex $i 9]]
  71.         if {$mgrt == "wm" || $base == "."} {
  72.             set base $name
  73.         } elseif {$level == 0} {
  74.             set mgrt pack
  75.             set mgri "-side top -expand 1 -fill both"
  76.         }
  77.         if {$level > 0} {
  78.             set name "$base$wdgt"
  79.         }
  80.         if {$type != "toplevel"} {
  81.             append todo "$type $name \\\n"
  82.             append todo "[vTcl:clean_pairs [vTcl:name_replace $base $opts] 4]\n"
  83.         }
  84.         if {$mgrt != "" && $mgrt != "wm" && $name != " "} {
  85.             if {$mgrt == "place" && $mgri == ""} {
  86.                 set mgri "-x 5 -y 5"
  87.             }
  88.             append todo "$mgrt $name \\\n[vTcl:clean_pairs $mgri 4]\n"
  89.         }
  90.         set index 0
  91.         incr level
  92.         foreach j $bind {
  93.             set e [lindex $j 0]
  94.             set c [vTcl:name_replace $base [lindex $j 1]]
  95.             append todo "bind $name $e \"$c\"\n"
  96.         }
  97.         foreach j $menu {
  98.             set t [lindex $j 0]
  99.             set o [lindex $j 1]
  100.             if {$t != "tearoff"} {
  101.                 append todo "$name add $t $o\n"
  102.             }
  103.         }
  104.         foreach j $chld {
  105.             append todo "[vTcl:tclet_from_cmpd $base $name \{$j\} $level]\n"
  106.             incr index
  107.         }
  108.         if {$alis != ""} {
  109.             set widget($alis) $name
  110.             set widget(rev,$name) "$alis"
  111.         }
  112.         foreach j $grid {
  113.             set cmd [lindex $j 0]
  114.             set num [lindex $j 1]
  115.             set prop [lindex $j 2]
  116.             set val [lindex $j 3]
  117.             if {$name == ""} {
  118.                 append todo "grid $cmd . $num $prop $val\n"
  119.             } else {
  120.                 append todo "grid $cmd $name $num $prop $val\n"
  121.             }
  122.         }
  123.         foreach j $proc {
  124.             set nme [lindex $j 0]
  125.             set arg [lindex $j 1]
  126.             set bdy [lindex $j 2]
  127.             append todo "proc $nme \{$arg\} \{\n$bdy\n\}\n"
  128.         }
  129.     }
  130.     return $todo
  131. }
  132.  
  133.